home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Fred (editor) utilities.sea / Fred (editor) utilities / undefine.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  7.6 KB  |  214 lines  |  [TEXT/CCL2]
  1. ;;; -*- Package: CL-USER -*-
  2.  
  3. (in-package "CL-USER")
  4.  
  5. #| undefine.lisp
  6. Commands for undefining variables, functions, methods, and classes 
  7. defined at the top level.  This is easily extensible for other
  8. defining forms.  Please send improvements.
  9.  
  10. Contributed largely by:
  11. Carl L. Gay <cgay@cs.uoregon.edu>
  12. and
  13. Steve Miner (PW Tech Centre miner@tc.pw.com)
  14.  
  15. Edited and maintained by:
  16. Daniel LaLiberte
  17. National Center for Supercomputing Applications
  18. University of Illinois, Urbana-Champaign
  19. liberte@ncsa.uiuc.edu
  20. |#
  21.  
  22. (defparameter *prompt-to-undefine* nil)
  23. (defparameter *offer-to-delete-definition* nil)
  24.  
  25.  
  26. ;;#################################################################
  27. ;; Some general utilities extracted from Carl's code.
  28.  
  29. (defun buffer-top-level-sexp-bounds (buffer)
  30.   "Return the top-level sexp bounds, or nil if there is none.
  31. The top level sexp starts with left paren in the first column.
  32. The current position may be just before the left paren, 
  33. or before the next top-level sexp."
  34.   (let* ((sexp-start-string #.(format nil "~%("))
  35.          (top-level-sexp-start
  36.           (if (and (= (buffer-column buffer) 0)
  37.                      (char-equal (buffer-char buffer) #\()) ;; looking at \(            (buffer-position buffer)
  38.             (buffer-position buffer)
  39.             (let ((foo (buffer-string-pos buffer sexp-start-string :from-end t)))
  40.               (and foo (+ foo 1))))))
  41.     (if (null top-level-sexp-start)
  42.       nil
  43.       (multiple-value-bind (sexp-start sexp-end)
  44.                            (buffer-current-sexp-bounds buffer top-level-sexp-start)
  45.         (if (null sexp-start)
  46.           nil
  47.           (values sexp-start sexp-end))
  48.         ))))
  49.  
  50. (defun buffer-top-level-sexp (buffer)
  51.   "Return the top-level sexp or nil if none."
  52.   (let ((start (buffer-top-level-sexp-bounds buffer)))
  53.     (if start
  54.       (buffer-current-sexp buffer start)
  55.       nil)))
  56.  
  57. #|#################################################################
  58. By Carl L. Gay
  59.  
  60. [Modified to:
  61.   - use buffer-top-level-sexp-bounds
  62.   - call Steve Miner's undefmethod
  63.  liberte]
  64.  
  65. |#
  66. ;;; ________________________________________
  67. ;;; Kill Definition 
  68.  
  69. (defgeneric ed-undefine (w)
  70.   (:documentation
  71.    "Find the definition under the point, determine if it's killable, if so
  72. prompt the user, kill the definition, and then optionally remove the
  73. definition from the buffer (or comment it out?)"))
  74.  
  75. (defmethod ed-undefine ((w fred-window))
  76.   (flet ((set-minibuffer (&rest args) (ed-beep) (apply 'set-mini-buffer w args)))
  77.     ;; error exit might be better
  78.     (let* ((buffer (fred-buffer w))
  79.            (sexp-start (buffer-top-level-sexp-bounds buffer))
  80.            (sexp (buffer-current-sexp buffer sexp-start))
  81.            (defining-form nil)
  82.            (undefine-fun nil))
  83.       (if (or (atom sexp)
  84.               (not (atom (setq defining-form (car sexp))))
  85.               (not (setq undefine-fun (get (car sexp) 'undefine))))
  86.         (set-minibuffer "Don't know how to undefine ~A."
  87.                         (if defining-form (format nil "a ~A" defining-form) sexp))
  88.         (let ((definition-name (second sexp)))
  89.           (catch-cancel
  90.             (when (or (null *prompt-to-undefine*)
  91.                       (y-or-n-dialog (format nil "Undefine ~S ~S?"
  92.                                              defining-form definition-name)))
  93.               (format t "un-~s: ~A~%" defining-form 
  94.                       (apply undefine-fun (cdr sexp))))
  95.             (when (and *offer-to-delete-definition*
  96.                        (y-or-n-dialog (format nil "Remove definition of ~S ~S from buffer?"
  97.                                               defining-form definition-name)))
  98.               (multiple-value-bind (sexp-start sexp-end)
  99.                                    (buffer-current-sexp-bounds buffer sexp-start)
  100.                 (buffer-delete buffer sexp-start sexp-end))
  101.               )))))))
  102.  
  103. ;;(comtab-set-key *control-x-comtab* '(:control :meta #\d) 'ed-undefine)
  104.   (def-fred-command (:control #\z) ed-undefine)
  105.  
  106. (defun undefine-variable (symbol &rest qlb)
  107.   (declare (ignore qlb))
  108.   (if (boundp symbol)
  109.     (makunbound symbol)))
  110.  
  111. (defun undefine-defun (symbol &rest qlb)
  112.   (declare (ignore qlb))
  113.   (if (fboundp symbol)
  114.     (fmakunbound symbol)))
  115.  
  116. (defun undefine-defmethod (symbol &rest qlb)
  117.   (if (fboundp symbol)
  118.     (eval `(undefmethod ,symbol ,@qlb))))
  119.  
  120. (defun undefine-defclass (symbol &rest qlb)
  121.   (declare (ignore qlb))
  122.   (when (find-class symbol nil)
  123.     (setf (find-class symbol) nil)
  124.     symbol))
  125.  
  126. (dolist (foo '(defvar defparameter defconstant))
  127.   (setf (get foo 'undefine) 'undefine-variable))
  128.  
  129. (setf (get 'defun 'undefine) 'undefine-defun)
  130. (setf (get 'defmacro 'undefine) 'undefine-defun)
  131. (setf (get 'defmethod 'undefine) 'undefine-defmethod)
  132. (setf (get 'defclass 'undefine) 'undefine-defclass)
  133.  
  134. #|#################################################################
  135. The following is for undefining methods only.
  136. By Steve Miner
  137. [Modified ed-undefmethod to look for top-level sexp. - liberte]
  138. |#
  139.  
  140. (defun remove-lambda-keywords (lambda-list)
  141.   (cond ((endp lambda-list) nil)
  142.         ((member (car lambda-list) lambda-list-keywords :test #'eq)
  143.      nil)
  144.         (t (cons (car lambda-list) (remove-lambda-keywords 
  145.                                     (cdr lambda-list))))))
  146.  
  147.  
  148. (defun class-list-spec (lambda-list)
  149.   (mapcar #'(lambda (arg) (cond ((symbolp arg) '(find-class 't))
  150.                                 ((symbolp (cadr arg)) `(find-class
  151.                             ',(cadr arg)))
  152.                                 ((eq (caadr arg) 'eql) `(list 'eql
  153.                              ,(cadadr
  154.                                arg)))
  155.                                 (t (error "Malformed lambda-list ~S."
  156.                       lambda-list))))
  157.           (remove-lambda-keywords lambda-list)))
  158.  
  159. ;;; NOTE: the order of the method qualifiers is significant so the
  160. ;;; NREVERSE is necessary.
  161. (defun get-lambda-and-quals (qlb)
  162.   "Returns multiple values, the lambda-list and the list of method
  163. qualifiers, from the QLB which is a list of method qualifiers, a
  164. lambda list and a body (essentially the method definition without the 
  165. DEFMETHOD or the method name -- the CDDR of the method definition if
  166. you will.)"
  167.   (let ((quals nil))
  168.     (dolist (x qlb)
  169.       (if (listp x)
  170.       (return (values x (nreverse quals)))
  171.       (push x quals)))))
  172.  
  173.  
  174.  
  175. (defmacro undefmethod (name &rest qlb)
  176.   "Removes method that is specified using the same syntax as
  177. DEFMETHOD.  The body is ignored.
  178. With this macro, you could just change your defmethod to undefmethod, 
  179. and evaluate it to undefine it.
  180. BUG: if NAME has no symbol-function, an error results."
  181.   ;; QLB could be qualifier, lambda list, and body.  We'll end up
  182.   ;; ignoring the body
  183.   (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
  184.     `(let* ((func (symbol-function ',name))
  185.             (meth (find-method func ',quals 
  186.                                (list ,@(class-list-spec lambda-list))
  187.                    nil)))
  188.        (when meth
  189.          (remove-method func meth)
  190.          (values meth :undefmethod)))))
  191.  
  192.  
  193. (defmacro find-defmethod (name &rest qlb)
  194.   "Finds method that is specified using the same syntax as DEFMETHOD.
  195. The body is ignored."
  196.   ;; QLB could be qualifier, lambda list, and body.  We'll end up
  197.   ;; ignoring the body
  198.   (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
  199.     `(find-method (symbol-function ',name) ',quals 
  200.                   (list ,@(class-list-spec lambda-list)) nil)))
  201.  
  202.  
  203. ;;; Bind this to a Fred Key
  204. (defmethod ed-undefmethod ((w fred-window))
  205.   "Undefine the method defined by the surrounding defmethod."
  206.   (let ((sexp (buffer-top-level-sexp (fred-buffer w))))
  207.     (if (and sexp (eq (car sexp) 'defmethod))
  208.       (format t "undefmethod ~A~%" (eval (cons 'undefmethod (cdr sexp))))
  209.       (ed-beep))))
  210.  
  211. ;For example,
  212. ;  (def-fred-command (:control #\z) ed-undefmethod)
  213.  
  214.